perm filename FLIP.LSP[901,BGB] blob
sn#129625 filedate 1974-11-12 generic text, type T, neo UTF8
(SETQ IBASE (ADD1 7))
(DEFPROP ALLFNS
(NIL TEST
QFLIP
QUILT
ALLI
Q00
Q01
Q02
Q03
Q04
Q05
Q06
Q07
Q10
Q11
Q12
Q13
Q14
Q15
Q16
Q17
ALLPAC
Q1
Q2
Q3
Q4
XY
CAN
BUBBLE
ARDSFIT
BITS
SQRED
MVERTICAL
MHORIZONTAL
BVERTICAL
BHORIZONTAL
PACX
PACY
PACDX
PACDY
FLATTEN
FIT
MID
ADDPTS
PACLIST6
LSD3
LSD2
LSD1
PACLIST3
PACLIST2
PACLIST5
PACLIST4
PACLIST
FRAMEPAC
LONE-KILLER
INK-BLOT
ONE16
OPEN
CLOSE
MOMENT
MEANX
MEANY
SORT2
SORT
CROSSZ
HIST
DIFFS
CROSSINGS
PFLIP
PSET
PZIP
PNOT
MOVE
PXOR
PIOR
PAND
INITFLIP
SAFE
FINIT)
VALUE)
(DEFPROP TEST
(LAMBDA NIL (PROG NIL (VIDEO) (DSKTV 0 0 4 4) (ZIP) (TVADD 0) (SIEVE 0 0 1 10)))
EXPR)
(DEFPROP QFLIP
(NIL 4 -1020 -4 1120)
VALUE)
(DEFPROP QUILT
(LAMBDA (PAC) (PROG NIL (BLOB PAC NIL NIL NIL) (XYFLIP PAC) (BLOB 20 NIL QFLIP T)))
EXPR)
(DEFPROP ALLI
(LAMBDA(N)
(PROG NIL
(SIEVE 0 N 0 1)
(SIEVE 1 N 1 2)
(SIEVE 2 N 2 3)
(SIEVE 3 N 3 4)
(SIEVE 4 N 4 5)
(SIEVE 5 N 5 6)
(SIEVE 6 N 6 7)
(SIEVE 7 N 7 10)
(SIEVE 10 N 10 11)
(SIEVE 11 N 11 12)
(SIEVE 12 N 12 13)
(SIEVE 13 N 13 14)
(SIEVE 14 N 14 15)
(SIEVE 15 N 15 16)
(SIEVE 16 N 16 17)
(SIEVE 17 N 17 20)))
EXPR)
(DEFPROP Q00
(NIL 1 -1120 -1 1040)
VALUE)
(DEFPROP Q01
(NIL 1 -450 -1 1040)
VALUE)
(DEFPROP Q02
(NIL 1 0 -1 1040)
VALUE)
(DEFPROP Q03
(NIL 1 450 -1 1040)
VALUE)
(DEFPROP Q04
(NIL 1 -1120 -1 420)
VALUE)
(DEFPROP Q05
(NIL 1 -450 -1 420)
VALUE)
(DEFPROP Q06
(NIL 1 0 -1 420)
VALUE)
(DEFPROP Q07
(NIL 1 450 -1 420)
VALUE)
(DEFPROP Q10
(NIL 1 -1120 -1 0)
VALUE)
(DEFPROP Q11
(NIL 1 -450 -1 0)
VALUE)
(DEFPROP Q12
(NIL 1 0 -1 0)
VALUE)
(DEFPROP Q13
(NIL 1 450 -1 0)
VALUE)
(DEFPROP Q14
(NIL 1 -1120 -1 -420)
VALUE)
(DEFPROP Q15
(NIL 1 -450 -1 -420)
VALUE)
(DEFPROP Q16
(NIL 1 0 -1 -420)
VALUE)
(DEFPROP Q17
(NIL 1 450 -1 -420)
VALUE)
(DEFPROP ALLPAC
(LAMBDA NIL
(PROG NIL
(BLOB 0 NIL Q00 NIL)
(BLOB 1 NIL Q01 NIL)
(BLOB 2 NIL Q02 NIL)
(BLOB 3 NIL Q03 NIL)
(BLOB 4 NIL Q04 NIL)
(BLOB 5 NIL Q05 NIL)
(BLOB 6 NIL Q06 NIL)
(BLOB 7 NIL Q07 NIL)
(BLOB 10 NIL Q10 NIL)
(BLOB 11 NIL Q11 NIL)
(BLOB 12 NIL Q12 NIL)
(BLOB 13 NIL Q13 NIL)
(BLOB 14 NIL Q14 NIL)
(BLOB 15 NIL Q15 NIL)
(BLOB 16 NIL Q16 NIL)
(BLOB 17 NIL Q17 NIL)))
EXPR)
(DEFPROP Q1
(NIL 2 0 -2 1040)
VALUE)
(DEFPROP Q2
(NIL 2 -1120 -2 1040)
VALUE)
(DEFPROP Q3
(NIL 2 -1120 -2 0)
VALUE)
(DEFPROP Q4
(NIL 2 0 -2 0)
VALUE)
(DEFPROP XY
(LAMBDA NIL (CONS (TIMES 4 (MEANX 0)) (TIMES 4 (MEANY 0))))
EXPR)
(DEFPROP CAN
(LAMBDA NIL
(PROG NIL
(VIDEO)
(ZIP)
(DSKTV 0 0 4 4)
(TVADD 0)
(SIEVE 0 0 0 10)
(SETQ XX (PLUS (TIMES 4 (MEANX 0)) -100))
(COND ((MINUSP XX) (SETQ XX 0)))
(SETQ YY (PLUS (TIMES 4 (MEANY 0)) -100))
(COND ((MINUSP YY) (SETQ YY 0)))
(DSKTV XX YY 2 2)
(TVADD 1)
(SIEVE 1 1 0 10)
(SETQ XXX (PLUS (TIMES 2 (MEANX 1)) XX))
(COND ((MINUSP XX) (SETQ XX 0)))
(SETQ YYY (PLUS (TIMES 2 (MEANY 1)) YY))
(COND ((MINUSP YYY) (SETQ YYY 0)))
(DSKTV XXX YYY 1 1)
(TVADD 2)
(SIEVE 2 2 0 10)
(BLOB 0 NIL NIL NIL)
(BLOB 1 (LIST 2 XX 2 YY) NIL NIL)
(BLOB 2 (LIST 1 XXX 1 YYY) NIL NIL)))
EXPR)
(DEFPROP BUBBLE
(LAMBDA(ZZ)
(PROG (Z1 Z2)
(SETQ (REVERSE ZZ))
L1 (COND ((NULL (SETQ Z2 (REVERSE (CDR Z1)))) (RETURN NIL)))
L2 (COND ((OR (ZEROP (AREA (CAR Z1))) (NULL Z2)) (SETQ Z1 (CDR Z1)) (GO L1)))
(BLIT (CAR Z2) 20)
(BLIT (CAR Z1) 21)
(PIOR 21 (CAR Z2))
(PAND 20 (CAR Z1))
(SETQ Z2 (CDR Z2))
(GO L2)))
EXPR)
(DEFPROP ARDSFIT
(LAMBDA(XL XH XD ABC FLAG)
(PROG (X Y A B C V1 V2)
(SETQ X XL)
(SETQ A (CAR ABC))
(SETQ B (CADR ABC))
(SETQ C (CADDR ABC))
(SETQ Y (PLUS (TIMES (PLUS (TIMES A X) B) X) C))
(SETQ V1
(CONS (FIX (PLUS (COND (FLAG (PLUS X X)) (T (PLUS Y Y))) -700))
(FIX (DIFFERENCE 700 (COND (FLAG (PLUS Y Y)) (T (PLUS X X)))))))
L (COND ((GREATERP (SETQ X (PLUS X XD)) XH) (RETURN NIL)))
(SETQ Y (PLUS (TIMES (PLUS (TIMES A X) B) X) C))
(SETQ V2
(CONS (FIX (PLUS (COND (FLAG (PLUS X X)) (T (PLUS Y Y))) -700))
(FIX (DIFFERENCE 700 (COND (FLAG (PLUS Y Y)) (T (PLUS X X)))))))
(ARDS-VECTOR (CONS V1 V2))
(SETQ V1 V2)
(GO L)))
EXPR)
(DEFPROP BITS
(LAMBDA(NN)
(PROG (TEM FLAG)
(SETQ BASE 2)
(SETQ TEM (EXAMINE NN))
(SETQ FLAG (MINUSP TEM))
(SETQ TEM (EXPLODE (COND (FLAG (BOOLE 1 377777777777 TEM)) (T TEM))))
L (COND ((NOT (EQ (LENGTH TEM) 44)) (SETQ TEM (CONS 0 TEM)) (GO L)))
(SETQ BASE (ADD1 7))
(RETURN (COND (FLAG (CONS 1 (CDR TEM))) (T TEM)))))
EXPR)
(DEFPROP SQRED
(LAMBDA (X) (TIMES X X))
EXPR)
(DEFPROP MVERTICAL
(NIL . 2.9240992)
VALUE)
(DEFPROP MHORIZONTAL
(NIL . 3.0590820)
VALUE)
(DEFPROP BVERTICAL
(NIL . 68.660156)
VALUE)
(DEFPROP BHORIZONTAL
(NIL . 77.378906)
VALUE)
(DEFPROP PACX
(NIL . 0)
VALUE)
(DEFPROP PACY
(NIL . 0)
VALUE)
(DEFPROP PACDX
(NIL . 6)
VALUE)
(DEFPROP PACDY
(NIL . 6)
VALUE)
(DEFPROP FLATTEN
(LAMBDA (Z) (COND ((NULL Z) NIL) ((ATOM Z) (LIST Z)) (T (APPEND (FLATTEN (CAR Z)) (FLATTEN (CDR Z))))))
EXPR)
(DEFPROP FIT
(LAMBDA(L)
(PROG (EL SX SX2 SX3 SX4 SY SXY SX2Y N TX TY D DA DB DC COEFL)
(SETQ EL (ADDPTS L))
(SETQ SX 0.0)
(SETQ SX2 0.0)
(SETQ SX3 0.0)
(SETQ SX4 0.0)
(SETQ SY 0.0)
(SETQ SXY 0.0)
(SETQ SX2Y 0.0)
(SETQ N 0.0)
F5 (COND ((NULL EL) (GO F10)))
(SETQ TX (CAAR EL))
(SETQ TY (CDAR EL))
(SETQ SX (PLUS SX TX))
(SETQ SXY (PLUS SXY (TIMES TX TY)))
(SETQ SX3 (PLUS SX3 (TIMES TX TX TX)))
(SETQ TX (TIMES TX TX))
(SETQ SX2 (PLUS SX2 TX))
(SETQ SX2Y (PLUS SX2Y (TIMES TX TY)))
(SETQ SX4 (PLUS SX4 (TIMES TX TX)))
(SETQ SY (PLUS SY TY))
(SETQ N (ADD1 N))
(SETQ EL (CDR EL))
(GO F5)
F10 (SETQ D
(PLUS (TIMES SX4 SX2 N)
(TIMES SX3 SX SX2)
(TIMES SX2 SX3 SX)
(MINUS (TIMES SX2 SX2 SX2))
(MINUS (TIMES SX SX SX4))
(MINUS (TIMES N SX3 SX3))))
(SETQ DA
(PLUS (TIMES SX2Y SX2 N)
(TIMES SX3 SX SY)
(TIMES SX2 SXY SX)
(MINUS (TIMES SY SX2 SX2))
(MINUS (TIMES SX SX SX2Y))
(MINUS (TIMES N SXY SX3))))
(SETQ DB
(PLUS (TIMES SX4 SXY N)
(TIMES SX2Y SX SX2)
(TIMES SX2 SX3 SY)
(MINUS (TIMES SX2 SXY SX2))
(MINUS (TIMES SY SX SX4))
(MINUS (TIMES N SX3 SX2Y))))
(SETQ DC
(PLUS (TIMES SX4 SX2 SY)
(TIMES SX3 SXY SX2)
(TIMES SX2Y SX3 SX)
(MINUS (TIMES SX2 SX2 SX2Y))
(MINUS (TIMES SX SXY SX4))
(MINUS (TIMES SY SX3 SX3))))
(COND ((ZEROP D) (PRINT (QUOTE (ZERO DET)))))
(SETQ COEFL (LIST (QUOTIENT DA D) (QUOTIENT DB D) (QUOTIENT DC D)))
(RETURN COEFL)))
EXPR)
(DEFPROP MID
(LAMBDA (CL) (CONS (TIMES 0.5 (PLUS (CAAR CL) (CAADR CL))) (TIMES 0.5 (PLUS (CDAR CL) (CDADR CL)))))
EXPR)
(DEFPROP ADDPTS
(LAMBDA(L)
(PROG (L1 L2)
(SETQ L1 L)
(SETQ L2 NIL)
LL (COND ((NULL L1) (RETURN L2)))
(SETQ L2 (CONS (CAAR L1) (CONS (MID (CAR L1)) (CONS (CADAR L1) L2))))
(SETQ L1 (CDR L1))
(GO LL)))
EXPR)
(DEFPROP PACLIST6
(LAMBDA(NN)
(PROG (TEM)
(SETQ TEM (EXAMINE NN))
(COND ((NOT (MINUSP TEM)) (RETURN (EXPLODE TEM))))
(SETQ TEM (EXPLODE (BOOLE 1 377777777777 (EXAMINE NN))))
L (COND ((EQ (LENGTH TEM) 43) (RETURN (CONS 1 TEM))) (T (SETQ TEM (CONS 0 TEM))))
(GO L)))
EXPR)
(DEFPROP LSD3
(LAMBDA(W L)
(COND ((NULL L) NIL) (T (CONS (CONS (CDAR L) (PLUS (CDAR L) (TIMES (CAAR L) W))) (LSD3 W (CDR L))))))
EXPR)
(DEFPROP LSD2
(LAMBDA(L M B)
(PROG (L1 L2)
(SETQ L2 L)
(SETQ L1 NIL)
LL (SETQ L1
(CONS (CONS (TIMES (DIFFERENCE (REMAINDER (CAR L2) 100) 40) 0.3515625E-1)
(DIFFERENCE (TIMES (QUOTIENT (CAR L2) 100) M) B))
L1))
(COND ((NULL (SETQ L2 (CDR L2))) (RETURN L1)))
(GO LL)))
EXPR)
(DEFPROP LSD1
(LAMBDA(THRES)
(PROG (LV LH N M)
(SETQ LV (SETQ LH NIL))
(SETQ N (PLUS 10777 CLRS))
L (TYO 61)
(SETQ M (EXAMINE N))
(COND ((GREATERP (QUOTIENT M 1000000) THRES) (SETQ LV (CONS (DIFFERENCE N CLRS) LV))))
(COND ((GREATERP (REMAINDER M 1000000) THRES) (SETQ LH (CONS (DIFFERENCE N CLRS) LH))))
(COND ((EQ N CLRS) (RETURN (CONS LV LH))))
(SETQ N (SUB1 N))
(GO L)))
EXPR)
(DEFPROP PACLIST3
(LAMBDA(N L)
(COND ((NULL L) NIL) ((ZEROP (CAR L)) (PACLIST3 (SUB1 N) (CDR L))) (T (CONS N (PACLIST3 (SUB1 N) (CDR L))))))
EXPR)
(DEFPROP PACLIST2
(LAMBDA(NN)
(PROG (LL) (SETQ BASE 2) (SETQ LL (PACLIST3 43 (REVERSE (PACLIST6 NN)))) (SETQ BASE (ADD1 7)) (RETURN LL)))
EXPR)
(DEFPROP PACLIST5
(LAMBDA (Y L) (COND ((NULL L) NIL) (T (CONS (CONS (CAR L) Y) (PACLIST5 Y (CDR L))))))
EXPR)
(DEFPROP PACLIST4
(LAMBDA (L) (COND ((NULL L) NIL) (T (CONS (PLUS 44 (CAR L)) (PACLIST4 (CDR L))))))
EXPR)
(DEFPROP PACLIST
(LAMBDA(N)
(PROG (Y LL)
(SETQ LL NIL)
(SETQ Y 0)
L (SETQ LL
(APPEND (PACLIST5 Y
(APPEND (PACLIST2 (PLUS PC (TIMES N 200) Y Y))
(PACLIST4 (PACLIST2 (PLUS PC (TIMES N 200) Y Y 1)))))
LL))
(COND ((EQ 100 (SETQ Y (ADD1 Y))) (RETURN LL)))
(GO L)))
EXPR)
(DEFPROP FRAMEPAC
(LAMBDA(X Y DX DY L)
(PROG (LL1 LL2)
(SETQ LL1 L)
(SETQ LL2 NIL)
L (COND ((NULL LL1) (RETURN LL2)))
(SETQ LL2 (CONS (CONS (PLUS X (TIMES DX (CAAR LL1))) (PLUS Y (TIMES DY (CDAR LL1)))) LL2))
(SETQ LL1 (CDR LL1))
(GO L)))
EXPR)
(DEFPROP LONE-KILLER
(LAMBDA (N M P) (PROG2 (INK-BLOT N M P) (PAND M N)))
EXPR)
(DEFPROP INK-BLOT
(LAMBDA(N M P)
(PROG NIL
(YBLIT N P 1)
(MOVE P M)
(XSHIFT P -1)
(PIOR P M)
(XSHIFT P 2)
(PIOR P M)
(YBLIT N P -1)
(PIOR P M)
(XSHIFT P -1)
(PIOR P M)
(XSHIFT P 2)
(PIOR P M)
(XSHIFT N -1)
(PIOR N M)
(XSHIFT N 2)
(PIOR N M)
(XSHIFT N -1)))
EXPR)
(DEFPROP ONE16
(LAMBDA NIL
(PROG NIL
(ZIP)
(DSKTV 0 0 4 4)
(TVADD 0)
(DSKTV 0 1 4 4)
(TVADD 0)
(DSKTV 0 2 4 4)
(TVADD 0)
(DSKTV 0 3 4 4)
(TVADD 0)
(DSKTV 1 0 4 4)
(TVADD 0)
(DSKTV 1 1 4 4)
(TVADD 0)
(DSKTV 1 2 4 4)
(TVADD 0)
(DSKTV 1 3 4 4)
(TVADD 0)
(DSKTV 2 0 4 4)
(TVADD 0)
(DSKTV 2 1 4 4)
(TVADD 0)
(DSKTV 2 2 4 4)
(TVADD 0)
(DSKTV 2 3 4 4)
(TVADD 0)
(DSKTV 3 0 4 4)
(TVADD 0)
(DSKTV 3 1 4 4)
(TVADD 0)
(DSKTV 3 2 4 4)
(TVADD 0)
(DSKTV 3 3 4 4)
(TVADD 0)))
EXPR)
(DEFPROP OPEN
(LAMBDA NIL (JOINT 7 100))
EXPR)
(DEFPROP CLOSE
(LAMBDA NIL (JOINT 7 -110))
EXPR)
(DEFPROP MOMENT
(LAMBDA(N)
(PROG (A B C D)
(SETQ A (PLUS 0.0 (AREA N)))
(SETQ B (QUOTIENT (SUMX N) A))
(SETQ D (SUMSQX))
(SETQ C (QUOTIENT (SUMY N) A))
(RETURN (DIFFERENCE (PLUS D (SUMSQY)) (TIMES A B B) (TIMES A C C)))))
EXPR)
(DEFPROP MEANX
(LAMBDA (N) (QUOTIENT (SUMX N) (AREA N)))
EXPR)
(DEFPROP MEANY
(LAMBDA (N) (QUOTIENT (SUMY N) (AREA N)))
EXPR)
(DEFPROP SORT2
(LAMBDA (N M Z) (COND ((NULL (CDR Z)) N) (T (PROG2 (SIEVE N M (CAR Z) (CADR Z)) (SORT2 (ADD1 N) M (CDR Z))))))
EXPR)
(DEFPROP SORT
(LAMBDA(N M)
(PROG (Z)
(SETQ Z (CROSSZ M))
(RETURN
(COND ((NULL (CDR Z)) N) (T (PROG2 (SIEVE N M (CAR Z) (CADR Z)) (SORT2 (ADD1 N) M (CDR Z))))))))
EXPR)
(DEFPROP CROSSZ
(LAMBDA (N) (APPEND (CONS 0 (CROSSINGS (DIFFS (HIST N)) 1)) (QUOTE (20))))
EXPR)
(DEFPROP HIST
(LAMBDA(N)
(PROG (M Z)
(SETQ M 17)
(SETQ Z NIL)
L (SETQ Z (CONS (EXAMINE (PLUS (TIMES 20 N) HSTV M)) Z))
(COND ((EQ -1 (SETQ M (SUB1 M))) (RETURN Z)) (T (GO L)))))
EXPR)
(DEFPROP DIFFS
(LAMBDA (Z) (COND ((NULL (CDR Z)) NIL) (T (CONS (DIFFERENCE (CAR Z) (CADR Z)) (DIFFS (CDR Z))))))
EXPR)
(DEFPROP CROSSINGS
(LAMBDA(Z N)
(COND ((NULL (CDR Z)) NIL)
(T
(COND ((AND (MINUSP (CADR Z)) (NOT (MINUSP (CAR Z)))) (CONS N (CROSSINGS (CDR Z) (ADD1 N))))
(T (CROSSINGS (CDR Z) (ADD1 N)))))))
EXPR)
(DEFPROP PFLIP
(LAMBDA (A) (LOGIC 12 A A))
EXPR)
(DEFPROP PSET
(LAMBDA (A) (LOGIC 17 A A))
EXPR)
(DEFPROP PZIP
(LAMBDA (A) (LOGIC 0 A A))
EXPR)
(DEFPROP PNOT
(LAMBDA (A B) (LOGIC 12 A B))
EXPR)
(DEFPROP MOVE
(LAMBDA (A B) (LOGIC 5 A B))
EXPR)
(DEFPROP PXOR
(LAMBDA (A B) (LOGIC 6 A B))
EXPR)
(DEFPROP PIOR
(LAMBDA (A B) (LOGIC 7 A B))
EXPR)
(DEFPROP PAND
(LAMBDA (A B) (LOGIC 1 A B))
EXPR)
(DEFPROP INITFLIP
(LAMBDA NIL
(PROG NIL
(FINIT)
(SETQ BFFR (CAR (GETSYM VAL BUFFER)))
(SETQ HSTV (CAR (GETSYM VAL HISTOV)))
(SETQ CLRS (CAR (GETSYM VAL COLORS)))
(SETQ PC (CAR (GETSYM VAL PAC)))))
EXPR)
(DEFPROP SAFE
(LAMBDA NIL (DSKOUT (FLIP . LSP) (GRINL ALLFNS)))
EXPR)
(DEFPROP FINIT
(LAMBDA NIL
(PROG2 (GETSYM SUBR
DDT
ARM
DAC
JOINT
TSINIT
LENS
SWS
ARM
DAC
JOINT
DSKTV
INDISK
LSD
ZIP
TVADD
TVSUB
FOCUS
PAN
TILT)
(GETSYM SUBR
LOGIC
HISTO
SIEVE
CLIY1
CLIY2
CLIX
PACKBUF
PACK
XMINW
AREA
YMIN
YMAX
YBLIT
XSHIFT
SUMY
SUMSQY
SUMX
IMULC
ADDC
TV
GRAD
PPP
TTT
FFF
STOPWAR
ASHV
SUMSQX
BLOB
ONEBLOB
BLIT
XYFLIP)))
EXPR)